home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / condition-precom.lisp < prev    next >
Lisp/Scheme  |  1991-07-08  |  2KB  |  62 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))
  4.  
  5. #-(or lucid excl genera)
  6. (progn
  7.  
  8. #+pcl
  9. (eval-when (compile load eval)
  10. (defun exercise-condition-classes ()
  11.   (let ((gfuns nil))
  12.     (dolist (name '(make-instance
  13.             initialize-instance
  14.             shared-initialize
  15.             print-object))
  16.       (push (pcl::gdefinition name) gfuns))
  17.     (labels ((do-class (class)
  18.            (dolist (gfun (pcl::specializer-generic-functions class))
  19.          (pushnew gfun gfuns))
  20.            (dolist (dsub (pcl::class-direct-subclasses class))
  21.          (do-class dsub))))
  22.       (do-class (find-class 'condition)))
  23.     (mapc #'pcl::exercise-generic-function gfuns))
  24.   nil)
  25. )
  26.  
  27. #+pcl
  28. (progn
  29. (eval-when (compile)
  30. (exercise-condition-classes)
  31. )
  32.  
  33. (pcl::precompile-random-code-segments clcs)
  34.  
  35. (eval-when (load eval)
  36. (exercise-condition-classes)
  37. )
  38. )
  39.  
  40. #+kcl (install-clcs-symbols)
  41.  
  42. )
  43.  
  44. (defun dsys::retry-operation (function retry-string)
  45.   (loop (with-simple-restart (retry retry-string)
  46.       (return-from dsys::retry-operation
  47.         (funcall function)))))
  48.  
  49. (defun dsys::operate-on-module (module initial-state system-operation)
  50.   (if (null dsys::*retry-operation-list*)
  51.       (dsys::operate-on-module1 module initial-state system-operation)
  52.       (let ((retry-operation (car (last dsys::*retry-operation-list*)))
  53.         (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*)))
  54.     (restart-bind ((retry 
  55.             #'(lambda (&rest ignore)
  56.                 (declare (ignore ignore))
  57.                 (funcall (car retry-operation)))
  58.             :report-function
  59.             #'(lambda (stream)
  60.                 (write-string (cdr retry-operation) stream))))
  61.        (dsys::operate-on-module module initial-state system-operation)))))
  62.